home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MATH.SWG / 0044_PATTERNS.pas < prev    next >
Pascal/Delphi Source File  |  1993-11-02  |  4KB  |  168 lines
  1. {
  2. WILLIAM SCHROEDER
  3.  
  4. I'd like to extend thanks to everyone For helping me set up a PATTERN Program.
  5. Yes, I have done it! Unfortunatley, this Program doesn't have all possible
  6. pattern searches, but I figured out an algorithm For increasing size geometric
  7. patterns such as 2 4 7 11. The formula produced is as follows: N = the Nth
  8. term. So whatever the formula, if you want to find an Nth term, get out some
  9. paper and replace N! :) Well, here's the Program, folks. I hope somebody can
  10. make some improvements on it...
  11. }
  12. Program PatternFinder;
  13.  
  14. Uses
  15.   Crt;
  16.  
  17. Var
  18.   ans     : Char;
  19.   PatType : Byte;
  20.   n1, n2,
  21.   n3, n4  : Integer;
  22.  
  23. Procedure GetInput;
  24. begin
  25.   ClrScr;
  26.   TextColor(lightcyan);
  27.   Writeln('This Program finds patterns For numbers in increasing size.');
  28.   Write('Enter the first four terms in order: ');
  29.   TextColor(yellow);
  30.   readln(n1, n2, n3, n4);
  31. end;
  32.  
  33. Procedure TestRelations;
  34. begin
  35.   PatType := 0;
  36.   { 1 3 5 }
  37.   if (n3 - n2 = n2 - n1) and ((n4 - n3) = n2 - n1) then
  38.     PatType := 1
  39.   else
  40.   { 1 3 9 }
  41.   if (n3 / n2) = (n4 / n3) then
  42.     PatType := 2
  43.   else
  44.   { 1 1 2 }
  45.   if (n3 = n2 + n1) and (n4 = (n3 + n2)) then
  46.     PatType := 3
  47.   else
  48.   { 1 2 4 7 11 }
  49.   if ((n4 - n3) - (n3 - n2)) = ((n3 - n2) - (n2 - n1)) then
  50.     PatType := 4;
  51. end;
  52.  
  53. Procedure FindFormula;
  54.  
  55.   Procedure DoGeoCalc;
  56.   Var
  57.     Factor : Real;
  58.     Dif,
  59.     Shift,
  60.     tempn,
  61.     nx, ny : Integer;
  62.   begin
  63.     Dif := (n3 - n2) - (n2 - n1);
  64.     Factor := Dif * 0.5;
  65.     Shift  := 0;
  66.     ny := n2;
  67.     nx := n1;
  68.     if ny > nx then
  69.     While (ny-nx) <> dif do
  70.     begin
  71.       Inc(Shift);
  72.       tempn := nx;
  73.       nx := nx - ((ny - nx) - dif);
  74.       ny := tempn;
  75.     end;
  76.     if Factor <> 1 then
  77.       Write('(', Factor : 0 : 1, ')');
  78.     if Shift = 0 then
  79.       Write('(N + 0)(N - 1)')
  80.     else
  81.     begin
  82.       if Shift > 0 then
  83.       begin
  84.         Write('(N + ', shift, ')(N');
  85.         if Shift = 1 then
  86.           Write(')')
  87.         else
  88.           Write(' + ', shift - 1, ')');
  89.       end;
  90.     end;
  91.     if nx <> 0 then
  92.       Writeln(' + ', nx)
  93.     else
  94.       Writeln;
  95.   end;
  96.  
  97. begin
  98.   TextColor(LightGreen);
  99.   Writeln('Formula =');
  100.   TextColor(white);
  101.   Case PatType of
  102.     1 :
  103.     begin
  104.       { Nth term = first term + difference * (N - 1) }
  105.       if n2 - n1 = 0 then
  106.         Writeln(n1)
  107.       else
  108.       if (n2 - n1 = 1) and (n1 - 1 = 0) then
  109.         Writeln('N')
  110.       else
  111.       if n2 - n1 = 1 then
  112.         Writeln('N + ', n1 - 1)
  113.       else
  114.       if (n2 - n1) = n1 then
  115.         Writeln(n1, 'N')
  116.       else
  117.       Writeln(n2 - n1, '(N - 1) + ', n1);
  118.     end;
  119.  
  120.     2 :
  121.     begin
  122.       { Nth term = first term * ratio^(N - 1) }
  123.       if n1 = 1 then
  124.         Writeln(n2 / n1 : 0 : 0, '^(N - 1)')
  125.       else
  126.         Writeln(n1, ' x ', n2 / n1 : 0 : 0, '^(N - 1)');
  127.     end;
  128.  
  129.     3 :
  130.     begin
  131.       { Fibonacci Sequence }
  132.       Writeln('No formula: Fibonacci Sequence (Term1 + Term2 = Term3)');
  133.       Writeln('                                ',
  134.               n1 : 5, ' + ', n2 : 5, ' = ', (n1 + n2) : 5);
  135.     end;
  136.  
  137.     4 :
  138.     begin
  139.       { Geometric Patterns }
  140.       DoGeoCalc;
  141.     end;
  142.   end;
  143. end;
  144.  
  145. begin
  146.   GetInput;
  147.   TestRelations;
  148.   TextColor(LightRed);
  149.   Writeln;
  150.   if PatType <> 0 then
  151.     FindFormula
  152.   else
  153.     Writeln('No pattern found: This Program may not know how to look '+
  154.     'for that pattern.');
  155.   TextColor(lightred);
  156.   Writeln;
  157.   Write('Press any key...');
  158.   ans := ReadKey;
  159.   ClrScr;
  160. end.
  161.  
  162. {
  163. That's all folks! if you can find and fix any bugs For me, please send me that
  164. section of the code so I can change it. if anybody cares to ADD to the pattern
  165. check, be my guest! This Program can be altered and used by ANYBODY. I'd just
  166. like to expand it a bit. Have fun!
  167. }
  168.